The Arsenal Files 6/The Arsenal Files 6 (Arsenal Computer).ISO/prg_basi/ddfedit.zip/DDFINDEX.FRM

Text File | 1996-02-05 | 19KB | 730 lines

VERSION 2.00
Begin Form FormIndexDDF
   BackColor       =   &H00C0C0C0&
   Caption         =   "Indexes for"
   ClientHeight    =   3390
   ClientLeft      =   2115
   ClientTop       =   4110
   ClientWidth     =   5475
   Height          =   3795
   Left            =   2055
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3390
   ScaleWidth      =   5475
   Top             =   3765
   Width           =   5595
   Begin SSPanel PanTop
      Align           =   1  'Align Top
      AutoSize        =   3  'AutoSize Child To Panel
      BevelOuter      =   0  'None
      BorderWidth     =   1
      Height          =   495
      Left            =   0
      TabIndex        =   7
      Top             =   0
      Width           =   5475
      Begin CommandButton FldCom
         Caption         =   "New &Part"
         Height          =   255
         Index           =   5
         Left            =   990
         TabIndex        =   15
         Top             =   0
         Width           =   1005
      End
      Begin CommandButton FldCom
         Caption         =   "&Down"
         Height          =   255
         Index           =   4
         Left            =   4320
         TabIndex        =   14
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Delete"
         Height          =   255
         Index           =   2
         Left            =   2790
         TabIndex        =   13
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Up"
         Height          =   255
         Index           =   3
         Left            =   3585
         TabIndex        =   12
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&Edit"
         Height          =   255
         Index           =   1
         Left            =   2070
         TabIndex        =   11
         Top             =   0
         Width           =   735
      End
      Begin CommandButton FldCom
         Caption         =   "&New Index"
         Height          =   255
         Index           =   0
         Left            =   0
         TabIndex        =   10
         Top             =   0
         Width           =   1005
      End
      Begin SSPanel PanHead
         AutoSize        =   3  'AutoSize Child To Panel
         BevelInner      =   1  'Inset
         BevelOuter      =   0  'None
         BorderWidth     =   1
         Height          =   255
         Left            =   0
         TabIndex        =   8
         Top             =   240
         Width           =   5475
         Begin TextBox TextTop
            BackColor       =   &H00C0C0C0&
            BorderStyle     =   0  'None
            Enabled         =   0   'False
            ForeColor       =   &H00FF0000&
            Height          =   195
            Left            =   30
            MultiLine       =   -1  'True
            TabIndex        =   9
            Text            =   "test test test"
            Top             =   30
            Width           =   5415
         End
      End
   End
   Begin TextBox XPath
      Height          =   285
      Left            =   0
      TabIndex        =   6
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin TextBox XFDFlags
      Height          =   285
      Left            =   960
      TabIndex        =   5
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin TextBox XFDLocation
      Height          =   285
      Left            =   720
      TabIndex        =   4
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin TextBox XFDName
      Height          =   285
      Left            =   480
      TabIndex        =   3
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin TextBox XFDid
      Height          =   285
      Left            =   240
      TabIndex        =   2
      Top             =   2280
      Visible         =   0   'False
      Width           =   180
   End
   Begin SSPanel PanList
      AutoSize        =   3  'AutoSize Child To Panel
      BevelInner      =   1  'Inset
      BevelOuter      =   0  'None
      BorderWidth     =   1
      Height          =   1650
      Left            =   0
      TabIndex        =   0
      Top             =   1320
      Width           =   4815
      Begin ListBox Llist
         Height          =   1590
         Left            =   30
         TabIndex        =   1
         Top             =   30
         Width           =   4755
      End
   End
End
Option Explicit
Dim CurrentOffset As Integer
Dim inited As Integer
Dim Local_File_Changed As Integer
Dim FieldArr() As XDField_def
Dim FieldLast As Integer
Dim indexArr() As XDIndex_def
Dim IndexLast As Integer
Dim CurrListIndex As Integer

Sub FieldArrfill ()
  Dim Keybuf As KeyBufDef
  Dim KeyBufLen As Integer
  Dim XDField As XDField_def
  Dim BufLen As Integer
  Dim stat As Integer
  Dim PosBlk As PosBlkDef
  Dim FileFullPath As String
  Dim X As Integer
  Dim XDFieldKey1 As XDFieldKey1_def
  Dim i As Integer
  Dim j As Integer
  Dim p1 As Integer
  Dim p2 As Integer

  Debug.Print "listfill"

  llist.Clear

  KeyBufLen = Len(Keybuf)
  BufLen = Len(XDField)

  ' first open the file
  FileFullPath = XPath & "Field.DDF"
  Keybuf.kb = FileFullPath
  KeyBufLen = Len(Keybuf)
  BufLen = 0

  stat = btrcall(B_OPEN, PosBlk, XDField, BufLen, Keybuf, KeyBufLen, 0)
  If stat <> 0 Then
    MsgBox "Btrieve Error Opening file " & FileFullPath & Chr(10) & stat & " " & BtErr(stat)
    Exit Sub
  End If


  KeyBufLen = Len(XDFieldKey1): BufLen = Len(XDField)
  XDFieldKey1.XeDFile = Val(XFDid.Text)
  stat = btrcall(B_GETGE, PosBlk, XDField, BufLen, XDFieldKey1, KeyBufLen, 1)

  CurrentOffset = 0
  FieldLast = 0
  Do
    If stat <> 0 Then Exit Do

    If XDField.XeDFile <> Val(XFDid.Text) Then Exit Do

    CurrListIndex = 0
    ReDim Preserve FieldArr(FieldLast)
    FieldArr(FieldLast) = XDField
    FieldLast = FieldLast + 1

    KeyBufLen = Len(XDFieldKey1): BufLen = Len(XDField)
    stat = btrcall(B_GETNX, PosBlk, XDField, BufLen, XDFieldKey1, KeyBufLen, 1)

  Loop

  If (stat <> 9 And stat <> 0) Then MsgBox "Btrieve Error Retrieving Record in FILE file " & Chr(10) & stat & " " & BtErr(stat)
  stat = btrcall(B_CLOSE, PosBlk, XDField, BufLen, Keybuf, KeyBufLen, 0)

End Sub

Sub FillNewIndexForm (Setto As Integer)
  Dim i As Integer
  Dim idx As Integer

  idx = -1
  FormNewIndex.FieldList.Clear
  For i = 0 To FieldLast - 1
    FormNewIndex.FieldList.AddItem Trim(FieldArr(i).XeDName)
    FormNewIndex.FieldList.ItemData(FormNewIndex.FieldList.NewIndex) = FieldArr(i).XeDid
    If Setto <> -1 Then
      If indexArr(Setto).XidField = FieldArr(i).XeDid Then idx = i
    End If
  Next i


  FormNewIndex.FieldList.ListIndex = idx

  If Setto <> -1 Then ' I've got to set the flags !!!!
    For i = 0 To 9
      If (indexArr(Setto).XiDFlags And (2 ^ i)) > 0 Then
        FormNewIndex.KeyFlag(i).Value = True
      Else
        FormNewIndex.KeyFlag(i).Value = False
      End If

    Next i
  End If


End Sub

Sub FldCom_Click (Index As Integer)

  Select Case Index
    Case 0: IndexNewIndex 'new Index
    Case 1: IndexEdit ' edit Index
    Case 2: IndexDelete ' delete Index
    Case 3: IndexMove (-1)' Move Index Up
    Case 4: IndexMove (1) ' Move Index Down
    Case 5: IndexNewPart
  End Select
End Sub

Sub Form_Activate ()
  Debug.Print "Activated"
  If inited Then Exit Sub
  Me.Caption = "Indexes for """ & Trim(XfDName.Text) & """ (" & Trim(XFDLocation.Text) & ")"
  If Val(XFDFlags.Text) = 16 Then
    FldCom(0).Enabled = False
    FldCom(1).Enabled = False
    FldCom(2).Enabled = False
    FldCom(3).Enabled = False
    FldCom(4).Enabled = False
  End If
  FieldArrfill
  IndexArrFill
  listfill
  If inited = False Then inited = True

End Sub

Sub Form_Load ()

  CurrListIndex = -1
  Local_File_Changed = False

  inited = False
End Sub

Sub Form_Resize ()
  If windowstate = 1 Then Exit Sub
  PanHead.Left = 0
  PanHead.Width = PanTop.Width
  PanList.Left = 0
  PanList.Width = ScaleWidth
  PanList.Top = PanTop.Height
  PanList.Height = ScaleHeight - PanList.Top
End Sub

Sub Form_Unload (Cancel As Integer)
  Dim r As Integer

  If Local_File_Changed Then
    r = MsgBox("Changes Made. Do you wish so save changes ?", 3 + 32, "Indexes Changed")
    Select Case r
      Case 2
        Cancel = True
      Case 6
        Indexes_Remove (XPath.Text), (Val(XFDid.Text))
        Indexes_Add
    End Select
  End If
End Sub

Sub IndexArrFill ()
  Dim Keybuf As KeyBufDef
  Dim KeyBufLen As Integer
  Dim XDIndex As XDIndex_def
  Dim BufLen As Integer
  Dim stat As Integer
  Dim PosBlk As PosBlkDef
  Dim FileFullPath As String
  Dim X As Integer
  Dim XDIndexKey0 As XDIndexKey0_def
  Dim i As Integer
  Dim j As Integer
  Dim p1 As Integer
  Dim p2 As Integer


'Type XDIndexKey0_def
'  XiDFile As Integer
'End Type

  Debug.Print "listfill"

  llist.Clear

  KeyBufLen = Len(Keybuf)
  BufLen = Len(XDIndex)

  ' first open the file
  FileFullPath = XPath & "Index.DDF"
  Keybuf.kb = FileFullPath
  KeyBufLen = Len(Keybuf)
  BufLen = 0

  stat = btrcall(B_OPEN, PosBlk, XDIndex, BufLen, Keybuf, KeyBufLen, 0)
  If stat <> 0 Then
    MsgBox "Btrieve Error Opening file " & FileFullPath & Chr(10) & stat & " " & BtErr(stat)
    Exit Sub
  End If


  KeyBufLen = Len(XDIndexKey0): BufLen = Len(XDIndex)
  XDIndexKey0.XiDFile = Val(XFDid.Text)
  stat = btrcall(B_GETGE, PosBlk, XDIndex, BufLen, XDIndexKey0, KeyBufLen, 0)


  IndexLast = 0
  Do
    If stat <> 0 Then Exit Do

    If XDIndex.XiDFile <> Val(XFDid.Text) Then Exit Do

  '  CurrListIndex = 0
    ReDim Preserve indexArr(IndexLast)
    indexArr(IndexLast) = XDIndex
    IndexLast = IndexLast + 1

    KeyBufLen = Len(XDIndexKey0): BufLen = Len(XDIndex)
    stat = btrcall(B_GETNX, PosBlk, XDIndex, BufLen, XDIndexKey0, KeyBufLen, 0)

  Loop

  If (stat <> 9 And stat <> 0) Then MsgBox "Btrieve Error Retrieving Record in FILE file " & Chr(10) & stat & " " & BtErr(stat)
  stat = btrcall(B_CLOSE, PosBlk, XDIndex, BufLen, Keybuf, KeyBufLen, 0)
  CurrListIndex = -1
End Sub

Sub IndexDelete ()

  Dim CurIdx As Integer

  CurIdx = llist.ListIndex

  If CurIdx = -1 Then Exit Sub

  llist.RemoveItem CurIdx

  If CurIdx > llist.ListCount - 1 Then
    CurrListIndex = llist.ListCount - 1
  Else
    CurrListIndex = CurIdx
  End If

  ListExtract
  ListAdjust
  listfill
  Local_File_Changed = True



End Sub

Sub IndexEdit ()

  Dim fidx As Integer
  fidx = llist.ListIndex
  If fidx = -1 Then Exit Sub

  Curr_file_Changed = Local_File_Changed


  Load FormNewIndex
  FormNewIndex.Caption = "Edit Index"
  FillNewIndexForm (fidx)
  FormNewIndex.IndexIdx = llist.ItemData(llist.ListIndex)
  FormNewIndex.IndexNewPart = 0


  FormNewIndex.XFDid.Text = Trim(XFDid.Text)
  FormNewIndex.XPath.Text = Trim(XPath.Text)
  FormNewIndex.IndexIdx = fidx
  FormNewIndex.Show 1
  Local_File_Changed = Curr_file_Changed
  If Local_File_Changed Then
    ListExtract
    ListAdjust
    CurrListIndex = IndexLast - 1
    listfill
  End If


End Sub

Sub Indexes_Add ()

  ' Add all Indexs to the current file XeDid
  ' XPath & Index.ddf

  Dim stat As Integer
  Dim KeyNum As Integer
  Dim PosBlk As PosBlkDef
  Dim Keybuf As KeyBufDef
  Dim KeyBufLen As Integer
  Dim BufLen As Integer
  Dim FileFullPath As String
  Dim XDIndex As XDIndex_def
  Dim i As Integer, r As Integer

' ************************************************************************************
' Now we add records to the Index.DDF file
' ************************************************************************************

  FileFullPath = XPath.Text & "Index.DDF"
  Keybuf.kb = FileFullPath
  KeyBufLen = Len(Keybuf)
  BufLen = 0

  status "Adding Indexs to file " & FileFullPath

  stat = btrcall(B_OPEN, PosBlk, XDIndex, BufLen, Keybuf, KeyBufLen, 0)
  If stat <> 0 Then
    MsgBox "Btrieve Error Opening file " & FileFullPath & Chr(10) & stat & " " & BtErr(stat)
    Exit Sub
  End If

  ' Records for FILE.DDF

  For i = 0 To IndexLast - 1
    r = AddRecordToIndexDDF(PosBlk, (Val(XFDid.Text)), (indexArr(i).XidField), (indexArr(i).XidNumber), (indexArr(i).XiDPart), (indexArr(i).XiDFlags))
  Next i

  stat = btrcall(B_CLOSE, PosBlk, XDIndex, BufLen, Keybuf, KeyBufLen, 0)


End Sub

Sub IndexMove (WhichWay As Integer)
  Dim CurIdx As Integer, NewIdx As Integer
  Dim i As Integer
  Dim TempArr As XDIndex_def

  CurIdx = llist.ListIndex

  If CurIdx = -1 Then Exit Sub

  NewIdx = CurIdx + WhichWay
  If NewIdx < 0 Then Exit Sub
  If NewIdx > llist.ListCount - 1 Then
    If llist.ListCount = 1 Then
      Exit Sub
    Else
      If MsgBox("You have reached the bottom of the list" & Chr(10) & "Do you wish to start a New Index with this Part ?", 4 + 32, "WARNING") = 6 Then
        indexArr(CurIdx).XidNumber = 999
      Else
        Exit Sub
      End If
    End If
  Else

    If indexArr(NewIdx).XidNumber <> indexArr(CurIdx).XidNumber Then
      If MsgBox("You are trying to move a part of an index into another index" & Chr(10) & "Are you Sure you wish to do this ?", 4 + 32, "WARNING") = 6 Then
        indexArr(CurIdx).XidNumber = indexArr(NewIdx).XidNumber
      Else
        Exit Sub
      End If
    Else
      TempArr = indexArr(NewIdx)
      indexArr(NewIdx) = indexArr(CurIdx)
      indexArr(CurIdx) = TempArr
    End If
    CurrListIndex = NewIdx
  End If
  ListAdjust

  listfill
  Local_File_Changed = True



End Sub

Sub IndexNewIndex ()

  Curr_file_Changed = Local_File_Changed
  Load FormNewIndex
  FormNewIndex.Caption = "Add New Index"
  FormNewIndex.XFDid.Text = XFDid.Text
  FormNewIndex.XPath.Text = XPath.Text
  FormNewIndex.IndexIdx = -1
  FormNewIndex.IndexNewPart = 0
  FillNewIndexForm (-1)
  FormNewIndex.Show 1
  Local_File_Changed = Curr_file_Changed
  If Local_File_Changed Then
    ListExtract
    ListAdjust
    CurrListIndex = IndexLast - 1
    listfill
  End If

End Sub

Sub IndexNewPart ()


  If llist.ListIndex = -1 Then Exit Sub

  Curr_file_Changed = Local_File_Changed
  Load FormNewIndex
  FormNewIndex.Caption = "Add New Part"
  FillNewIndexForm (-1)
  FormNewIndex.XFDid.Text = XFDid.Text
  FormNewIndex.XPath.Text = XPath.Text
  FormNewIndex.IndexIdx = llist.ItemData(llist.ListIndex)
  FormNewIndex.IndexNewPart = 1
  FormNewIndex.Show 1
  Local_File_Changed = Curr_file_Changed
  If Local_File_Changed Then
    ListExtract
    ListAdjust
    CurrListIndex = IndexLast - 1
    listfill
  End If


End Sub

Sub ListAdjust ()

  Dim i As Integer
  Dim CurrIndex As Integer

  Dim NewPart As Integer
  Dim NewIndex As Integer

'  XiDFile - Done Later
'  XidField As Integer                       ' Filed ID (XeDid in FILED.DFF above)
'  XiDNumber - Done Later
'  XiDPart - Done Later
'  XiDFlags As Integer                       ' Flags of Key

  ' first we renumber the indexes, just incase he's deleted some inbetween, and we ad the FIleID

  Debug.Print "*** INDEXES FOUND"
  For i = 0 To IndexLast - 1
    Debug.Print i; indexArr(i).XiDFile; indexArr(i).XiDPart
  Next i


  NewIndex = -1
  CurrIndex = -1
  NewPart = 0

  For i = 0 To IndexLast - 1
    ' set the file
    indexArr(i).XiDFile = Val(XFDid.Text)
    Debug.Print "Curr "; CurrIndex; "  Found "; indexArr(i).XidNumber
    If indexArr(i).XidNumber <> CurrIndex Then

      CurrIndex = indexArr(i).XidNumber
      NewIndex = NewIndex + 1
    End If
    Debug.Print "Setting Index to "; NewIndex
    indexArr(i).XidNumber = NewIndex

  Next i


  ' Now we renumber the parts and add seg flags accordingly

  NewPart = 0
  CurrIndex = 0
  For i = 0 To IndexLast - 1

    ' always remove the SEG Part from current index
    If (indexArr(i).XiDFlags And K_SEG) > 0 Then indexArr(i).XiDFlags = indexArr(i).XiDFlags - K_SEG

    If indexArr(i).XidNumber <> CurrIndex Then ' End of a key
      NewPart = 0
      CurrIndex = indexArr(i).XidNumber
    Else ' it's a segment of the key, therefore I have to add K_SEG to the PREVIOUS part (If we're not on Part 0 !)
      If i <> 0 Then
        indexArr(i - 1).XiDFlags = indexArr(i - 1).XiDFlags + K_SEG
        NewPart = NewPart + 1
      End If
    End If


    indexArr(i).XiDPart = NewPart




  Next i


End Sub

Sub ListExtract ()

  Dim i As Integer
  Dim ll As String
  Dim p1 As Integer, p2 As Integer


' first extract values from list into array

  IndexLast = llist.ListCount
  For i = 0 To IndexLast - 1
    ReDim Preserve indexArr(i)
    ll = llist.List(i)

    indexArr(i).XiDFile = -1 ' Will need to be recalculated starting from last



'  XiDFile - Done Later
'  XidField As Integer                       ' Filed ID (XeDid in FILED.DFF above)
'  XiDNumber - Done Later
'  XiDPart - Done Later
'  XiDFlags As Integer                       ' Flags of Key

 '  "Number"
    p1 = 1: p2 = InStr(p1, ll, Chr(9))
    indexArr(i).XidNumber = Val(Mid(ll, p1, p2 - p1))

 '  "Part" -skip
    p1 = p2 + 1: p2 = InStr(p1, ll, Chr(9))

 '  "Field"
    p1 = p2 + 1: p2 = InStr(p1, ll, Chr(9))
    indexArr(i).XidField = Val(Mid(ll, p1, p2 - p1))

 '  "Name" - skip
    p1 = p2 + 1: p2 = InStr(p1, ll, Chr(9))

 '  "Flags"
    p1 = p2 + 1
    indexArr(i).XiDFlags = Val(Mid(ll, p1))
  Next i

End Sub

Sub listfill ()
  'fills the index list

  Dim i As Integer, j As Integer
  Dim ll As String
  Dim Fid As Integer

  llist.Clear

  Texttop.Text = "Number" & Chr(9) & "Part" & Chr(9) & "Field" & Chr(9) & "Name" & Chr(9) & "Flags"

  For i = 0 To IndexLast - 1
    For j = 0 To FieldLast - 1
      If FieldArr(j).XeDid = indexArr(i).XidField Then
        Fid = j
        Exit For
      End If
    Next j

    llist.AddItem Format(indexArr(i).XidNumber, "0") & Chr(9) & Format(indexArr(i).XiDPart, "0") & Chr(9) & Format(indexArr(i).XidField, "0") & Chr(9) & Trim(FieldArr(Fid).XeDName) & Chr(9) & Format(indexArr(i).XiDFlags, "0")
    llist.ItemData(llist.NewIndex) = indexArr(i).XidNumber
  Next i
  llist.ListIndex = CurrListIndex

  i = AutoSetTabStopsCheck(llist, Texttop, False, False)

End Sub